﻿//////////////////////////////////////////////////////////////////////
// Monad support
//////////////////////////////////////////////////////////////////////

module CPFD.Monad

// ref: http://www.randomhacks.net/articles/2007/03/12/monads-in-15-minutes
type ListMonad() =
   // Semantics
   member o.Return(x) = [x]
   member o.Bind(m, f) = List.concat( List.map f m )
   member o.Zero() = []
   // Helpers
   member o.Guard(c) = if c then o.Return(()) else o.Zero()
 
// ref: http://matthewmanela.com/blog/parameterized-state-transformer-monad-in-f-2/
// ref: http://monads.haskell.cz/html/xformeranatomy.html
// ref: http://cs.hubfs.net/forums/thread/7472.aspx (combine, delay)
// ref: http://tomasp.net/articles/imperative-i-return.aspx (combine, delay)
type StateListMonad() =
    // Inner monad
    let listM = new ListMonad()
    // Semantics
    member o.Return(v) = fun st -> listM.Return(v, st)
    member o.ReturnFrom(x) = x
    member o.Bind(m, f) = fun st -> listM.Bind(m st, fun (v, st') -> f v st')
    member o.Zero() = fun st -> listM.Return((), st)
    member o.Combine(p1,dp2) = o.Bind(p1, fun _ -> dp2)
    member o.Delay(f) = f()
    member o.For(s, f) = Seq.map f s |> Seq.reduce (fun macc m  -> o.Combine(macc, m)) 
    // Control
    member o.mapM m xs  = o { 
            match xs with
            | x::rest -> 
                let! value = m x
                let! values = o.mapM m rest
                return value :: values
            | _ -> return []                    
        }
    member o.mapM_ m xs = o {
            match xs with 
            | x::rest -> 
                do! m x
                do! o.mapM_ m rest
            | _ -> return ()        
        }
    member o.replicateM n m = o {
            match n with
            | 0 -> return []
            | _ -> 
                let! x = m
                let! rest = o.replicateM (n-1) m 
                return x::rest            
        }
    member o.zipWithM_ f xs ys = o {
            match xs, ys with
            | x::rxs, y::rys -> 
                let m = f x y
                do! m 
                do! o.zipWithM_ f rxs rys
            | _ -> return ()        
        }
    // Helpers
    member o.Update(f) = fun st -> listM.Return((), f st)        
    member o.Get() = fun st -> listM.Return(st, st)
    member o.Set(st) = fun _ -> listM.Return((), st)
    member o.Execute(m, s0) = m s0 |> List.map fst
    member o.Lift(c) = fun st -> listM.Bind(c, fun x -> listM.Return(x,st))
    member o.Guard(c) = o.Lift(listM.Guard(c))
